home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / miscpas.zip / CRFONTS.PAS < prev    next >
Pascal/Delphi Source File  |  1986-02-09  |  16KB  |  420 lines
  1. program fonts(input,output);
  2. const
  3.       key1='TOGGLE'; key2=' '; key3='SHLT'; key4='SHRT'; key5='SHUP';
  4.       key6='SHDN'; key7='CLR'; key8='FILL'; key9='#'; key10='MENU';
  5.       keyins='+1'; keydel='-1';
  6.  
  7.       maxfont=255; bit1=0; bit8=7;
  8.  
  9.       dot=22; hline=205; vline=186; luc=201; ruc=187; rlc=188; llc=200;
  10.  {                   ═          ║        ╔        ╗        ╝        ╚    }
  11.  
  12.       { LOCATION OF FRAME. LUCR0 & LUCC0 LOCATE UPPER LEFT-HAND CORNER, WHILE
  13.         HSTEP & VSTEP DETERMINE ITS SIZE. }
  14.  
  15.       lucr0=3; lucc0=4; hstep=2; vstep=1;
  16.  
  17.       menur=5; menuc=40;
  18.  
  19. type
  20.     bigstr = string[80];
  21.     bytebits = bit1..bit8;
  22.     pattern_set = set of bytebits; char_pattern = array[1..8] of pattern_set;
  23.     file_name_type = string[14];
  24.     char_pattern_file = file of char_pattern;
  25.     reg_length = (reg_word,reg_byte);
  26.     regpack = record case reg_length of
  27.                      reg_word: (ax,bx,cx,dx,bpx,six,dix,dsx,esx,flagx: integer);
  28.                      reg_byte: (al,ah,bl,bh,cl,ch,dl,dh:Byte;
  29.                                 bp,si,di,ds,es,flag:integer);
  30.                      end;
  31.  
  32.    keys = (nokey,notfct,
  33.            f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,
  34.            home,up,pgup,lt,rt,en,dn,pgdn,ins,del);
  35.  
  36.    on_off = (on,off);
  37.  
  38. var
  39.     fonts: array[0..maxfont] of char_pattern;
  40.     filename1,filename2: file_name_type;
  41.     file1,file2:char_pattern_file;
  42.     fontno,fontnr,fontnc,xyr,xyc: integer;
  43.     key:keys; ch,chx:char;
  44.     i,j:integer;
  45.     currow,curcol:integer; { CURRENT LOGICAL CURSOR POSITION }
  46.     quit:boolean;
  47.  
  48. {*************************** P R O C E D U R E S  **************************}
  49. procedure Reverse; { CHANGES OUTPUT TO REVERSE VIDEO }
  50.           begin TextColor(black); TextBackGround(white); end;
  51.  
  52. procedure Normal; { CHANGES OUTPUT TO NORMAL VIDEO }
  53.           begin TextColor(white); TextBackGround(black); end;
  54.  
  55. function GetKey(var chx,ch:char): keys;
  56. const esc=27;
  57. begin
  58. if KeyPressed then begin  { READ KEYBOARD, AND MAP INTO 'KEYS' TYPE }
  59.    read(Kbd,ch); chx:=chr(0);
  60.    if ord(ch)=esc then
  61.       if KeyPressed then begin chx:=ch; read(Kbd,ch) end;
  62.  
  63.    if chx=chr(0) then GetKey:=notfct
  64.    else case ch of
  65.         ';':  GetKey:=f1;
  66.         '<':  GetKey:=f2;
  67.         '=':  GetKey:=f3;
  68.         '>':  GetKey:=f4;
  69.         '?':  GetKey:=f5;
  70.         '@':  GetKey:=f6;
  71.         'A':  GetKey:=f7;
  72.         'B':  GetKey:=f8;
  73.         'C':  GetKey:=f9;
  74.         'D':  GetKey:=f10;
  75.         'G':  GetKey:=home;
  76.         'H':  GetKey:=up;
  77.         'I':  GetKey:=pgup;
  78.         'K':  GetKey:=lt;
  79.         'M':  GetKey:=rt;
  80.         'O':  GetKey:=en;
  81.         'P':  GetKey:=dn;
  82.         'Q':  GetKey:=pgdn;
  83.         'R':  GetKey:=ins;
  84.         'S':  GetKey:=del;
  85.         else GetKey:=notfct;
  86.         end { CASE }
  87.     end {KEYPRESSED}
  88. else GetKey:=nokey;
  89. end; {GETKEY}
  90.  
  91. procedure BlinkVideo;
  92.           begin TextColor(white+blink) end;
  93.  
  94. function Locate_Row(i:integer): integer;
  95.          begin Locate_Row:=lucr0+vstep*i; end;
  96.  
  97. function Locate_Col(i:bytebits): integer;
  98.          begin Locate_Col:=lucc0+hstep*(i+1); end;
  99.  
  100. procedure GoToRC(row,col:integer);
  101.           begin GotoXY(col,row); end;
  102.  
  103. {**** REVERSE THE BITS IN A SET TYPE.  THE BIT NUMBERING FOR GRAPHICS
  104.       PATTERNS IS A MIRROR IMAGE OF THE BIT NUMBERING FOR PASCAL SETS. }
  105.  
  106. procedure RevFont(font:char_pattern;var tfont:char_pattern);
  107. var i:integer;
  108.  
  109. {*} procedure RevSet(pset:pattern_set;var tpset:pattern_set);
  110.     var i:bytebits;
  111.     begin tpset:=[];
  112.           for i:=bit1 to bit8 do if i in pset then tpset:=tpset + [bit8-i];
  113.     end;
  114.  
  115. begin
  116.    for i:=1 to 8 do RevSet(font[i],tfont[i]);
  117. end;
  118.  
  119. procedure Display_Coord(row:integer;col:bytebits);
  120. var x,y:integer;
  121. begin x:=WhereX; y:=WhereY; GoToRC(xyr,xyc); Reverse;
  122.       write(' ',row:1,',',col+1:1,' '); Normal;
  123.       GotoXY(x,y); end;
  124.  
  125. procedure Dot_Clr(i:integer;j:bytebits; cursor:on_off);
  126.           begin fonts[fontno][i]:= fonts[fontno][i] - [j];
  127.                 GoToRC(Locate_Row(i),Locate_Col(j));
  128.                 if cursor=on then begin
  129.                    Display_Coord(i,j); BlinkVideo; write(chr(dot)); Normal; end
  130.                 else write(' ');
  131.           end;
  132.  
  133. procedure Dot_Set(i:integer;j:bytebits; cursor:on_off);
  134.           begin fonts[fontno,i] := fonts[fontno,i] + [j];
  135.                 GoToRC(Locate_Row(i),Locate_Col(j));
  136.                 if cursor=on then begin
  137.                    Display_Coord(i,j); highvideo end
  138.                 else LowVideo;
  139.                 write(chr(dot));
  140.           Normal;
  141.           end;
  142.  
  143. procedure Dot_Cursor(row:integer;col:bytebits;cursor:on_off);
  144.           begin GoToRC(Locate_Row(row),Locate_Col(col));
  145.                 if col in fonts[fontno,row] then begin
  146.                    if cursor=on then begin
  147.                       Display_Coord(row,col); highvideo end
  148.                    else LowVideo; write(chr(dot)) end
  149.                 else if cursor=on then begin
  150.                         Display_Coord(row,col);BlinkVideo; write(chr(dot)); end
  151.                      else write(' ');
  152.            Normal;
  153.            end;
  154.  
  155. procedure Line25; { PRINTOUT THE LINE 25 INFORMATION }
  156. var keyno:integer;
  157.   procedure writekey(key:bigstr);
  158.             begin Normal; keyno:=keyno+1;
  159.             if keyno<>1 then write(' ');
  160.             if keyno<=10 then write(keyno:1)
  161.             else if keyno=11 then write('INS') else write('DEL');
  162.             Reverse; write(key); Normal; end;
  163.  
  164. begin
  165.    GotoXY(1,25);  keyno:=0;
  166.    writekey(key1); writekey(key2); writekey(key3); writekey(key4); writekey(key5);
  167.    writekey(key6); writekey(key7); writekey(key8); writekey(key9); writekey(key10);
  168.    writekey(keyins); writekey(keydel);
  169. end; {LINE25}
  170.  
  171. procedure Display_Border;
  172. var i,rtcol,btmrow:integer;
  173. begin
  174.    highvideo;
  175.  
  176.    { WRITE OUT CORNER CHARACTERS }
  177.    GoToRC(lucr0,lucc0); write(chr(luc));
  178.    rtcol:=lucc0+9*hstep; GoToRC(lucr0,rtcol); write(chr(ruc));
  179.    btmrow:=lucr0+9*vstep; GoToRC(btmrow,lucc0); write(chr(llc));
  180.    GoToRC(btmrow,rtcol); write(chr(rlc));
  181.  
  182.    { WRITE OUT LINES OF FRAME }
  183.    for i:=lucc0+1 to rtcol-1 do begin
  184.        GoToRC(lucr0,i); write(chr(hline)); GoToRC(btmrow,i); write(chr(hline)); end;
  185.    for i:=lucr0+1 to btmrow-1 do begin
  186.        GoToRC(i,lucc0); write(chr(vline)); GoToRC(i,rtcol); write(chr(vline)); end;
  187.  
  188.    { INITIALIZE THE SCREEN POSITION OF THE FONT NUMBER }
  189.    fontnr:=lucr0-1; fontnc:=rtcol-4;
  190.    xyr:=fontnr; xyc:=lucc0;
  191.  
  192. end; { DISPLAY_BORDER }
  193.  
  194. procedure Display_FontNo(fontno:integer);
  195.           begin Reverse; GoToRC(fontnr,fontnc); write(' ',fontno:3,' '); Normal; end;
  196.  
  197. procedure Display_Fonts(font:char_pattern);
  198. var i,row:integer; col,j:bytebits;
  199. begin
  200.     LowVideo;
  201.     for i:=1 to 8 do begin
  202.         row:=Locate_Row(i); { GET SCREEN POSITION OF THE Ith ROW }
  203.         for j:=bit1 to bit8 do begin
  204.             col:=Locate_Col(j); { GET SCREEN POSITION OF THE Jth COLUMN }
  205.             GoToRC(row,col);
  206.             if j in font[i] then write(chr(dot)) else write(' ');
  207.             end;
  208.         end;
  209.     currow:=1; curcol:=bit1; Dot_Cursor(currow,curcol,on);
  210. end; { DISPLAY A FONT }
  211.  
  212. procedure Display_Font(fontno:integer);
  213. begin Display_Fonts(fonts[fontno]); end;
  214.  
  215. procedure Menus;
  216. label to_lbl,from_lbl,num_lbl;
  217. const romofs=$fa6e; romseg=$f000;
  218. var cmd:1..4; qrow:integer;
  219.     font:char_pattern;
  220.     sfont,dfont,code,num,i,strpos,xpos,ypos:integer;
  221.     instring: string[80];
  222.     rom:boolean;
  223.     pattern: pattern_set; membyte:Byte Absolute pattern;
  224.     ans:char;
  225.     filename:file_name_type;
  226.  
  227.   {*}procedure Write_Option(row:integer;str:bigstr);
  228.   begin
  229.      GoToRC(row,menuc); write(str); end;
  230.  
  231.   {*}procedure Clear_Rows(row:integer);
  232.   var i:integer;
  233.   begin
  234.       for i:=row to 24 do begin GoToRC(i,menuc); ClrEol; end;
  235.   end;
  236.  
  237.   {*}function Open_Input_File(var filevar:char_pattern_file;filename:file_name_type):boolean;
  238.   begin
  239.       Open_Input_File:=true;
  240.       Assign(filevar,filename); {$I-} reset(filevar); {$i+}
  241.       if IOResult <> 0 then begin
  242.          GoToRC(24,menuc); write('NON-EXISTENT FILE'); Open_Input_File:=false end;
  243.   end;
  244.  
  245.   {*}procedure Strip_Lblanks(var str:bigstr);
  246.      var i:integer; done:boolean;
  247.      begin done:=false;
  248.            while (str[1]=' ') and (not done) do
  249.                  begin Move(str[2],str[1],length(str)-1);
  250.                        str[0]:=chr(ord(str[0])-1);
  251.                        if ord(str[0])<=0 then done:=true; end;
  252.         end; { STRIP }
  253.  
  254. begin
  255.      Write_Option(menur,'1. QUIT');
  256.      Write_Option(menur+1,'2. READ FILE');
  257.      Write_Option(menur+2, '3. WRITE FILE');
  258.      Write_Option(menur+3,'4. COPY FONTS');
  259.      Write_Option(menur+5,'COMMAND: ');
  260.      read(cmd);
  261.      qrow:=menur+7; Clear_Rows(qrow);
  262.      case cmd of
  263.      1: begin GoToRC(qrow,menuc); write('SURE ? (Y/N): ');
  264.               read(ans); if (ans='y') or (ans='Y') then quit:=true; end;
  265.      2: begin
  266.           GoToRC(qrow,menuc); write('INPUT FILENAME:'); read(filename1);
  267.           if Open_Input_File(file1,filename1) then begin
  268.              dfont:=0; while not eof(file1) do begin
  269.                               read(file1,font);
  270.                               RevFont(font,fonts[dfont]);
  271.                               dfont:=(dfont+1) mod 256; end;
  272.              close (file1); end;
  273.           write(' OK'); Display_Font(fontno); end;
  274.      3: begin
  275.           GoToRC(qrow,menuc);
  276.           if length(filename2)=0 then filename2:=filename1;
  277.           write('OUTPUT FILENAME (',filename2,'): '); read(filename);
  278.           if length(filename)<>0 then filename2:=filename;
  279.           Assign(file2,filename2); rewrite(file2);
  280.           for sfont:=0 to maxfont do begin
  281.               RevFont(fonts[sfont],font); write(file2,font); end;
  282.           close(file2); write(' OK'); end;
  283.      4: begin
  284. to_lbl:
  285.            GoToRC(qrow,menuc); write('TO (',fontno:1,'):');
  286.            dfont:=fontno; {$I-} read(dfont); {$i+}
  287.            if IOResult <> 0 then goto to_lbl;
  288.  
  289. from_lbl:  GoToRC(qrow+1,menuc); write('FROM (<FONT#> | ROM <FONT#>):');
  290.            xpos:=WhereX; ypos:=WhereY; read(instring);
  291.            { PARSE INSTRING; IF CONTAINS WORD 'ROM' THEN COPY FROM ROM }
  292.            strpos:=pos('ROM',instring); rom:=false;
  293.            if strpos<>0 then begin rom:=true; delete(instring,strpos,3);end;
  294.            Strip_Lblanks(instring); val(instring,sfont,code);
  295.            if code<>0 then begin
  296.               GotoXY(xpos,ypos); ClrEol; goto from_lbl; end;
  297.  
  298. num_lbl:
  299.            GoToRC(qrow+2,menuc); write('NUM (1):'); num:=1; {$I-}read(num); {$i+}
  300.            if IOResult <> 0 then goto num_lbl;
  301.  
  302.            if rom then begin
  303.               Move(Mem[romseg:(romofs+sfont*8)],fonts[dfont],num*8);
  304.               for i:=dfont to dfont+num-1 do {REVERSE BIT PATTERNS}
  305.                   RevFont(fonts[i],fonts[i]);
  306.               end
  307.            else Move(fonts[sfont],fonts[dfont],num*8);
  308.            write(' OK'); Display_Font(fontno); end; { 4 }
  309.  
  310.       else { DO NOTHING } end; { case }
  311. end; { MENUS }
  312.  
  313. procedure Perform(key:keys); { MAJOR ROUTINE FOR EXECUTING THE NON-MENU COMMANDS }
  314. var i:integer; j:bytebits;
  315. begin
  316.     case key of
  317.     f1: { TURN ON BIT }
  318.         if curcol in fonts[fontno,currow] then Dot_Clr(currow,curcol,on)
  319.                                           else Dot_Set(currow,curcol,on);
  320.     f2: { NOTHING IMPLEMENTED };
  321.     f3: begin { SHIFT LEFT }
  322.         for j:=bit1 to bit8 do for i:=1 to 8 do
  323.             if j=bit8 then Dot_Clr(i,j,off)
  324.             else if j+1 in fonts[fontno,i] then Dot_Set(i,j,off)
  325.                                            else Dot_Clr(i,j,off);
  326.         Dot_Cursor(currow,curcol,on); end;
  327.     f4: begin { SHIFT RIGHT }
  328.         for j:=bit8 downto bit1 do for i:=1 to 8 do
  329.             if j=bit1 then Dot_Clr(i,j,off)
  330.             else if j-1 in fonts[fontno,i] then Dot_Set(i,j,off)
  331.                                            else Dot_Clr(i,j,off);
  332.         Dot_Cursor(currow,curcol,on); end;
  333.     f5: begin { SHIFT UP }
  334.         for i:=1 to 8 do for j:=bit1 to bit8 do
  335.             if i=8 then Dot_Clr(i,j,off)
  336.             else if j in fonts[fontno,i+1] then Dot_Set(i,j,off)
  337.                                            else Dot_Clr(i,j,off);
  338.         Dot_Cursor(currow,curcol,on); end;
  339.     f6: begin { SHIFT DOWN }
  340.         for i:=8 downto 1 do for j:=bit1 to bit8 do
  341.             if i=1 then Dot_Clr(i,j,off)
  342.             else if j in fonts[fontno,i-1] then Dot_Set(i,j,off)
  343.                                            else Dot_Clr(i,j,off);
  344.         Dot_Cursor(currow,curcol,on); end;
  345.     f7: begin { CLEAR FONT }
  346.         for i:=1 to 8 do for j:=bit1 to bit8 do Dot_Clr(i,j,off);
  347.         currow:=1; curcol:=0; Dot_Cursor(1,0,on); end;
  348.     f8: begin { FILL FONT }
  349.         for i:=1 to 8 do for j:=bit1 to bit8 do Dot_Set(i,j,off);
  350.         currow:=1; curcol:=0; Dot_Cursor(1,0,on); end;
  351.     f9: { GET NEW FONT NUMBER TO DISPLAY }
  352.         begin GoToRC(fontnr,fontnc); Reverse; read(fontno);
  353.         Display_FontNo(fontno); Display_Font(fontno) end;
  354.     ins:{ NEXT FONT }
  355.         begin fontno:=(fontno+1)mod 256;
  356.         Display_FontNo(fontno); Display_Font(fontno) end;
  357.     del:{ PREVIOUS FONT }
  358.         begin fontno:=(fontno+255) mod 256;
  359.         Display_FontNo(fontno); Display_Font(fontno) end;
  360.     f10:{ MENUS }
  361.         Menus;
  362.     { CURSOR MOVEMENT ROUTINES }
  363.     home: begin Dot_Cursor(currow,curcol,off);
  364.                 currow:=(currow+6)mod 8+1; curcol:=(curcol+7)mod 8;
  365.                 Dot_Cursor(currow,curcol,on); end;
  366.     up:   begin Dot_Cursor(currow,curcol,off);
  367.                 currow:=(currow+6)mod 8+1;
  368.                 Dot_Cursor(currow,curcol,on); end;
  369.     pgup: begin Dot_Cursor(currow,curcol,off);
  370.                 currow:=(currow+6)mod 8+1; curcol:=(curcol+1) mod 8;
  371.                 Dot_Cursor(currow,curcol,on); end;
  372.     lt:   begin Dot_Cursor(currow,curcol,off);
  373.                 curcol:=(curcol+7)mod 8;
  374.                 Dot_Cursor(currow,curcol,on); end;
  375.     rt:   begin Dot_Cursor(currow,curcol,off);
  376.                 curcol:=(curcol+1) mod 8;
  377.                 Dot_Cursor(currow,curcol,on); end;
  378.     en:   begin Dot_Cursor(currow,curcol,off);
  379.                 currow:=currow mod 8+1; curcol:=(curcol+7)mod 8;
  380.                 Dot_Cursor(currow,curcol,on); end;
  381.     dn:   begin Dot_Cursor(currow,curcol,off);
  382.                 currow:=currow mod 8+1;
  383.                 Dot_Cursor(currow,curcol,on); end;
  384.     pgdn: begin Dot_Cursor(currow,curcol,off);
  385.                 currow:=currow mod 8+1; curcol:=(curcol+1) mod 8;
  386.                 Dot_Cursor(currow,curcol,on); end;
  387.     end;
  388. end; { PERFORM }
  389.  
  390. procedure Center_Write(row:integer; str:bigstr);
  391. var col:integer;
  392. begin col:=41-length(str) div 2; GotoXY(col,row); write(str); end;
  393.  
  394. begin  {************** MAIN PROGRAM ********************}
  395.     { SIGN ON }
  396.     ClrScr; Reverse;
  397.     Center_Write(8,' C R E A T E   F O N T S ');
  398.     Center_Write(10,' B Y ');
  399.     Center_Write(12, ' L .  J .  W I N K L E R ');
  400.     Center_Write(16,' COPYRIGHT 1984 LAWRENCE J. WINKLER ');
  401.     Normal; Delay(4000); ClrScr;
  402.  
  403.     { INITIALIZE VARIABLES }
  404.     for fontno:=0 to maxfont do for i:=1 to 8 do fonts[fontno,i]:=[];
  405.     fontno:=0; currow:=1; curcol:=bit1; quit:=false;
  406.     filename1:=''; filename2:='';
  407.     Line25;
  408.     Display_Border;
  409.     Display_FontNo(fontno); Display_Font(fontno);
  410.  
  411.     while not quit do
  412.           if KeyPressed then begin
  413.              key:=GetKey(chx,ch);
  414.              if (key <> nokey) and (key <> notfct) then Perform(key);
  415.              end;
  416.  
  417.     GoToRC(24,10); writeln(' C R E A T E   F O N T S   TERMINATING');
  418.  
  419. end.
  420.